Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/odlist/odlist.frm

Visual Basic Form | 1994-12-06 | 11.4 KB | 301 lines

VERSION 2.00
Begin Form Form1
   BorderStyle     =   1  'Fixed Single
   Caption         =   "VB Messenger Owner-Draw ListBox Sample"
   ClientHeight    =   5415
   ClientLeft      =   6135
   ClientTop       =   2970
   ClientWidth     =   7755
   Height          =   5820
   Left            =   6075
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5415
   ScaleWidth      =   7755
   Top             =   2625
   Width           =   7875
   Begin ListBox List1
      Height          =   2370
      Left            =   180
      TabIndex        =   8
      Top             =   2430
      Width           =   3495
   End
   Begin PictureBox picFile
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   195
      Left            =   3300
      Picture         =   ODLIST.FRX:0000
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   7
      Top             =   5970
      Width           =   195
   End
   Begin PictureBox picDir
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   195
      Left            =   3060
      Picture         =   ODLIST.FRX:00E2
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   6
      Top             =   5970
      Width           =   195
   End
   Begin CommandButton Command1
      Cancel          =   -1  'True
      Caption         =   "End Demo"
      Default         =   -1  'True
      Height          =   435
      Left            =   2970
      TabIndex        =   1
      Top             =   4890
      Width           =   1575
   End
   Begin VBMsg VBMsg1
      Height          =   420
      Left            =   7140
      MessageCount    =   ODLIST.FRX:01C4
      MessageList     =   ODLIST.FRX:01C6
      MessageTypes    =   0  'Selected Messages
      PostDefault     =   0   'False
      Top             =   4830
      Width           =   420
   End
   Begin Frame Frame1
      Caption         =   "Description"
      Height          =   4665
      Left            =   3810
      TabIndex        =   2
      Top             =   120
      Width           =   3795
      Begin Label Label3
         BackStyle       =   0  'Transparent
         Caption         =   "This sample program uses VB Messenger to trap the WM_DRAWITEM message that gets sent to the form (the parent of the list box) and draws a picture with text for each item.  This sample also uses the Windows API extensively."
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H00FF0000&
         Height          =   1035
         Left            =   180
         TabIndex        =   5
         Top             =   3450
         Width           =   3435
      End
      Begin Label Label2
         BackStyle       =   0  'Transparent
         Caption         =   "When an item in the list box needs to be drawn (i.e., because of a repaint or if focus or the selection has changed), Windows sends the parent control (or form) a WM_DRAWITEM message.  With that message comes a pointer to a data structure (or Type) that contains all the information needed to draw the item (such as the rectangle in which to draw it)"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H00FF0000&
         Height          =   1665
         Left            =   180
         TabIndex        =   4
         Top             =   1680
         Width           =   3435
      End
      Begin Label Label1
         BackStyle       =   0  'Transparent
         Caption         =   "This sample program uses VB Messenger to display an owner-draw list box.  Owner-draw means that all drawing of text and/or pictures that appear in the list box is drawn by the programmer, rather than automatically handled by the list box itself."
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H00FF0000&
         Height          =   1170
         Left            =   180
         TabIndex        =   3
         Top             =   360
         Width           =   3435
         WordWrap        =   -1  'True
      End
   End
   Begin ListBox lstOwnerDraw
      Height          =   2175
      Left            =   180
      TabIndex        =   0
      Top             =   210
      Width           =   3495
   End
Option Explicit
Sub Command1_Click ()
    End
End Sub
Sub DrawItem (lpdis As DRAWITEMSTRUCT)
    Dim rc&
    Dim lpstr$
    Dim hdcSource%, cx%, cy%
    Dim cSelBack&
    'If no items in list box yet, indicate focus for
    'specified rectangle
    If (lpdis.itemID = -1) Then
    DrawFocusRect lpdis.hDC, lpdis.rcItem
    Exit Sub
    End If
    'If Windows wants us to draw the entire item of just change
    'the selection state, we do this stuff
    If (lpdis.itemAction And ODA_DRAWENTIRE) Or (lpdis.itemAction And ODA_SELECT) Then
    'If the item it is selected, fill in the rectangle
    'with the system color for highlight. If not selected,
    'fill the rectangle with the standard window color.
    'Also, the the background and foreground colors
    'appropriately based on selection.
    If (lpdis.itemState And ODS_SELECTED) Then
        cSelBack = GetSysColor(COLOR_HIGHLIGHT)
        rc = SetBkColor(lpdis.hDC, cSelBack)
        rc = SetTextColor(lpdis.hDC, GetSysColor(COLOR_HIGHLIGHTTEXT))
        DrawSelectionRect lpdis, cSelBack
    Else
        cSelBack = GetSysColor(COLOR_WINDOW)
        rc = SetBkColor(lpdis.hDC, cSelBack)
        rc = SetTextColor(lpdis.hDC, GetSysColor(COLOR_WINDOWTEXT))
        DrawSelectionRect lpdis, cSelBack
    End If
    'If the item is a directory, use the picDir picture
    'else use the picFile picture.  The hDC property
    'is used for drawing with the Windows API as we will
    'do next.
    If (lstOwnerDraw.ItemData(lpdis.itemID)) Then
        hdcSource = picDir.hDC
    Else
        hdcSource = picFile.hDC
    End If
    'All Windows API calls require that coordinates and sizes
    'be in pixels.
    cx = picDir.Width / Screen.TwipsPerPixelX
    cy = picDir.Height / Screen.TwipsPerPixelY
    'This function copies the image in the picture box
    'to an area specified
    rc = BitBlt(lpdis.hDC, lpdis.rcItem.left, lpdis.rcItem.top, cx, cy, hdcSource, 0, 0, SRCCOPY)
    'Now, draw the text using the DrawText Windows API
    lpdis.rcItem.left = lpdis.rcItem.left + cx + 5
    lpstr = lstOwnerDraw.List(lpdis.itemID)
    rc = DrawText(lpdis.hDC, lpstr, Len(lpstr), lpdis.rcItem, DT_VCENTER Or DT_SINGLELINE)

    'if item has focus, do additional drawing -- dashed border
    If (lpdis.itemState And ODS_FOCUS) Then
        DrawFocusRect lpdis.hDC, lpdis.rcItem
    End If
    Exit Sub
    End If
    'If only focus has changed, display or hide the focus rectangle.
    'DrawFocusRect will display the dotted rectangle if one isn't
    'already there, otherwise if there is one it will clear it.
    If (lpdis.itemAction And ODA_FOCUS) Then
    DrawFocusRect lpdis.hDC, lpdis.rcItem
    Exit Sub
    End If
End Sub
'This routine fills an area (a rectangle) with a color
Sub DrawSelectionRect (lpdis As DRAWITEMSTRUCT, cSelBack As Long)
    Dim rc&
    Dim hbrSel%, hbrOld%
    hbrSel = CreateSolidBrush(cSelBack)
    hbrOld = SelectObject(lpdis.hDC, hbrSel)
    rc = FillRect(lpdis.hDC, lpdis.rcItem, hbrSel)
    rc = SelectObject(lpdis.hDC, hbrOld)
    rc = DeleteObject(hbrSel)
End Sub
Sub Form_Load ()
    Dim lpm As MODEL
    Dim rc&
    Dim attr%, f$, Path$
    Dim lSaveStyle&
    'Subclass the form since the form gets the child controls'
    'WM_DRAWITEM messages
    VBMsg1 = hWnd
    'The control model is what a VBX uses to keep track of
    'internal information such as window styles
    rc = ptGetControlModel(lstOwnerDraw, lpm)
    lSaveStyle = lpm.flWndStyle
    lpm.flWndStyle = lpm.flWndStyle Or LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
    ptSetControlModel lstOwnerDraw, lpm
    'since we changed the style, we need to recreate the list box
    rc = ptRecreateControlHwnd(lstOwnerDraw)
    'Now we need to reset the style so other list boxes
    'will be normal
    rc = ptGetControlModel(lstOwnerDraw, lpm)
    lpm.flWndStyle = lSaveStyle
    ptSetControlModel lstOwnerDraw, lpm
    'when you recreate a window, it becomes invisible so
    'we need to reset the Visible property
    lstOwnerDraw.Visible = True
    'Load our list box with data
    'This example loads the list box with files and directories
    'of the root of the current drive
    attr = ATTR_READONLY Or ATTR_HIDDEN Or ATTR_SYSTEM Or ATTR_DIRECTORY
    Path = "\"
    f = Dir(Path + "*.*", attr)
    Do While f <> ""
    lstOwnerDraw.AddItem LCase(f)
    List1.AddItem LCase(f)
    If GetAttr(Path + f) And ATTR_DIRECTORY Then
        lstOwnerDraw.ItemData(lstOwnerDraw.NewIndex) = True
    Else
        lstOwnerDraw.ItemData(lstOwnerDraw.NewIndex) = False
    End If
    f = Dir
    Loop
End Sub
Sub VBMsg1_WindowMessage (hWindow As Integer, msg As Integer, wParam As Integer, lParam As Long, RetVal As Long, CallDefProc As Integer)
    Select Case msg
    'WM_MEASUREITEM is sent to the parent window (the form)
    'so that we can return the dimensions of each item in the
    'list box.  This list box was created using the
    'LBS_OWNERDRAWFIXED style.  Therefore, this message is
    'only sent once to get the dimensions of all items.
    'if instead we used the LBS_OWNERDRAWVARIABLE style,
    'this message would be sent for each item in the list.
    Case WM_MEASUREITEM

        'MEASUREITEMSTRUCT contains information on the size
        'of each item in the list.
        Dim lpmis As MEASUREITEMSTRUCT

        'This VBMSG internal API copies data at an address
        '(which in this case is stored in lParam) to a Type
        'variable
        ptGetTypeFromAddress lParam, lpmis, Len(lpmis)

        'Set the items' height to 13 pixels
        lpmis.itemHeight = 13
        'now write the structure back to the address
        ptCopyTypeToAddress lParam, lpmis, Len(lpmis)

        'Always return TRUE and don't call the Windows default processing
        RetVal = True
        CallDefProc = False
    'This message is sent to draw a specific item in the list.
    Case WM_DRAWITEM
        'DRAWITEMSTRUCT contains information on how to draw
        'the item in the list such as the selection/focus state
        'and the rectangle
        Dim lpdis As DRAWITEMSTRUCT

        'This VBMSG internal API copies data at an address
        '(which in this case is stored in lParam) to a Type
        'variable
        ptGetTypeFromAddress lParam, lpdis, Len(lpdis)
        'Call the routine that draws the entier item
        DrawItem lpdis

        'Always return TRUE and don't call the Windows default processing
        RetVal = True
        CallDefProc = False
    End Select
End Sub